;;###########################################################################
;; guidemp2.lsp
;; Contains code for guidemap context sensitive help.
;; Copyright (c) 1992-97 by Forrest W. Young
;;###########################################################################



(defmeth guidemap-proto :delay-return-to-parent-guidemap ()
"Args: None
Prepares for delayed return to parent of present guidemap. Used by Return button."
  (send *vista* :delay-return t))

(defmeth guidemap-proto :return-to-parent-guidemap ()
"Args: None
Returns to parent of present guidemap. Used by icon-action."
(when investigate 
  (format t "In RETURN-TO-PARENT-GM - ABOUT TO ENTER R&U ~%GuideMap Ancestors: ~f~%" (send current-object :guidemap-ancestors))
(check)(break))
  (cond 
    ((send current-object :guidemap-ancestors)
     (send *guidemap* :retrieve-and-update-guidemap
           (first (send current-object :guidemap-ancestors)))
     (send current-object :guidemap-number 
           (first (send current-object :guidemap-ancestors)))
     (send current-object :guidemap-ancestors
           (rest (send current-object :guidemap-ancestors))))
    (t
     (setcd (first (send current-object :dob-parents)))))
  (send *vista* :delay-return nil)
  t)

(defmeth guidemap-proto :goto-new-object (string)
"Args: STRING
Switches current-object to the object whose title is STRING. STRING is either 1) the title of the goto data object; 2) the generic title of the goto data object (the portion of the title up to the first dash) when the goto data object is a child of another object; or 3) 'model', for goto model objects." 
  (cond 
    ((equal "model" (string-downcase string)) (setcm current-model))
    (t (let* ((child-title nil)
              (position nil)
              (object nil)
              (children (send current-object :dob-children))
              (child nil)
              (child-icon nil)
              (num-children (length children))
              (goto-title nil))
         (when children
               (dotimes (i num-children)
                        (setf child (select children i))
                        (setf child-icon
                              (select (send *workmap* :icon-list)
                                      (1- (send child :icon-number))))
                        (setf child-title (send child-icon :title))
                        (setf position (search-string "-" child-title))
                        (when position
                              (setf goto-title 
                                    (subseq child-title 0 position))
                              (when investigate
                                    (format t "Found: ~a~%" goto-title))
                              (when (equal goto-title string) 
                                    (setf object 
                                          (eval (intern (string-upcase 
                                                         child-title))))))))
         (when (not object) 
               (setf object (eval (intern (string-upcase string)))))
         (setcd object)))))

(defmeth guidemap-proto :created-data ()
"Args: None
Updates title of attached guidemap goto button when data are created by a Create-Data guidemap button."
  (let* ((active-button-number (send self :selected-icon));not updated
         (to-icon-num-list 
          (select (send self :connection-list) active-button-number))
         (to-icon nil)
         (j (1- (length (send *workmap* :icon-list))))
         (newtitle nil)
         ) 
    (dolist (i to-icon-num-list)
            (setf to-icon (select (send self :icon-list) i))
            (when (equal "GoTo:New Data" (send to-icon :title))
                  (setf newtitle (strcat "GoTo:"
                       (send (select (send *workmap* :icon-list) j) :title))))
            (when (equal "Link:Model" (send to-icon :title))
                  (setf newtitle (strcat "Link:"
                       (send current-model :model-abbrev))))
            (when newtitle
                  (send to-icon :title newtitle)
                  (setf (select (send self :icon-title) i) newtitle)
                  (send to-icon :make-action)
                  (send self :redraw)
                  (setf newtitle nil))))
  t)

(defmeth guidemap-proto :update-slot-info (slot-list)
"Args: SLOT-LIST
Updates guidemap slots from SLOT-LIST"
  (send self :NUM-ICONS (select slot-list 1))
  (send self :CONNECTION-LIST (select slot-list 2))
  (send self :X (select slot-list 3))
  (send self :Y (select slot-list 4))
  (send self :ICON-TYPE (select slot-list 5))
  (send self :ICON-TITLE (select slot-list 6))
  (send self :ICON-NUMBER-LIST (select slot-list 7))
  (send self :REDRAW-ORDER (select slot-list 8))
  (send self :SELECTED-ICON (select slot-list 9))
  (send self :TOOLBAR t)
  (send self :NUM-DATA-ICONS (select slot-list 11))
  (send self :NUM-MODEL-ICONS (select slot-list 12))
  (send self :DATA-ICON-NUMBER-LIST (select slot-list 13))
  (send self :MODEL-ICON-NUMBER-LIST (select slot-list 14))
  (send self :SELECTED-DATA-ICON (select slot-list 15))
  (send self :PREVIOUSLY-SELECTED-DATA-ICON (select slot-list 16))
  (send self :NUM-DATA-MENU-ITEMS (select slot-list 17))
  (send self :NUM-MODEL-MENU-ITEMS (select slot-list 18))
  (send self :ACTIVE-BUTTON-LIST (select slot-list 19))
  (send self :ICON-LIST (select slot-list 20))
  (send self :DATA-ICON-LIST (select slot-list 21))
  (send self :MODEL-ICON-LIST (select slot-list 22))
  (send self :TITLE (select slot-list 0))
  )

(defmeth guidemap-proto :slot-list ()
"Args: none
Returns a list of the current guidemap slot information"
  (list
   (send self :TITLE) 
   (send self :NUM-ICONS) 
   (send self :CONNECTION-LIST)
   (send self :X)
   (send self :Y)
   (send self :ICON-TYPE)
   (send self :ICON-TITLE)
   (send self :ICON-NUMBER-LIST)
   (send self :REDRAW-ORDER)
   (send self :SELECTED-ICON)
   (send self :TOOLBAR)
   (send self :NUM-DATA-ICONS) 
   (send self :NUM-MODEL-ICONS) 
   (send self :DATA-ICON-NUMBER-LIST)
   (send self :MODEL-ICON-NUMBER-LIST)
   (send self :SELECTED-DATA-ICON)
   (send self :PREVIOUSLY-SELECTED-DATA-ICON) 
   (send self :NUM-DATA-MENU-ITEMS)
   (send self :NUM-MODEL-MENU-ITEMS) 
   (send self :ACTIVE-BUTTON-LIST)
   (send self :ICON-LIST)
   (send self :DATA-ICON-LIST)
   (send self :MODEL-ICON-LIST)))

(defmeth guidemap-proto :load-guidemap (guidemap-name)
"Args: GUIDEMAP-NAME
If guidemap, loads the guidemap information file GUIDEMAP-NAME. If guided-applet, gets the guidemap information from *guided-applet*. Used this information to generate icon information."
  (let ((string (send self :string))
        (result  nil)
        (ab-list nil)
        (icon-objectid-list nil))
    (when investigate
          (format t "Ready to Load Guidemap ~a of type ~a~%" 
                  guidemap-name string)
          (format t "System has guidemap number ~g~%" 
                  (send *vista* :guidemap-number))
          (check)
          (break)
          )

    (cond 
      ((send *vista* :internal-map)
       (eval *guided-applet*)
       (send *vista* :internal-map nil)
       (setf result t))
      (t
       (setf result (load (strcat *guide-dir-name* 
                                  (string-downcase guidemap-name))))))
    (setf icon-objectid-list (send self :icon-list))
    (when result 
          (setf ab-list (send self :active-button-list))
          (dotimes (i (send self :num-icons))
                   (cond 
                     ((= (select (send self :icon-type) i) 7); 'and' icon
                      (send (select icon-objectid-list i) 
                            :icon-state "normal"))
                     (t
                      (send (select icon-objectid-list i) 
                            :icon-state "grey"))))
          (cond 
            ((not ab-list)
             (send (select icon-objectid-list 0) :icon-state "selected"))
            (t
             (dolist (i ab-list)
                     (send (select icon-objectid-list i)
                           :icon-state "selected"))))
          (dotimes (i (send self :num-icons))
                  (send (select icon-objectid-list i) :window *guidemap*))
          (send self :instant-return nil)
          )
    (when (not result) 
          (error (format nil "No GuideMap File named~% ~a" 
                         (strcat *guide-dir-name* guidemap-name))))
    result))

(defun guidemap-window ()
"Args: None
GuideMap-Window object constructor function.  This function creates a guidemap window, but does not create a map.  The map is created by the code in the guidemap file. Returns window object-id."
  (let ((prev-container)
        (object))
#+containers
    (progn 
     (send *watcher* :write-text "Constructing Container")
     (cond
       (*desktop-container* (enable-container *desktop-container*))
       (t
        (when *active-container*
              (setf prev-container *active-container*)
              (disable-container *active-container*))
        (setf *desktop-container* 
              (make-container :free t :local-menus t :type 1 :show nil)))))
    (send *watcher* :write-text "Constructing GuideMap")
    (setf object (send guidemap-proto :new 2 :title "ViSta GuideMap" :location (list 0 0)))
    (menus t)
    (apply #'send object :size (send *vista* :guide-window-size))
    (apply #'send object :frame-location (send *vista* :guide-window-location))
    (send *vista* :guidemap t)
    (send object :menu nil)
    (send object :toolbar t)
    (send object :back-color 'workmap-background)
    (send object :has-v-scroll (second (send object :size)))
    
#+containers
    (progn
     (send *watcher* :write-text "Showing GuideMap")
     (if prev-container 
         (enable-container prev-container)
         (disable-container))
     ;(send object :pop-out t)
     ;(send object :location 200 200)
     )
    (setf *guidemap* object)
    (send *guidemap* :gui t)
    (refresh-desktop)
    object))

(defun make-icon (w x y title icon-type)
  (let ((obj nil)
        )
    (cond
      ((= icon-type 1) 
       (setf obj (send dob-icon-proto   :new w x y 25 32 :title title)))
      ((= icon-type 2) 
       (setf obj (send tool-icon-proto  :new w x y 45 13 :title title)))
      ((= icon-type 3) 
       (setf obj (send mob-icon-proto   :new w x y 25 32 :title title)))
      ((= icon-type 4) 
       (setf obj (send dib-icon-proto   :new w x y 25 32 :title title)))
      ((= icon-type 5)
       (setf obj (send tab-icon-proto   :new w x y 25 32 :title title)))
      ((= icon-type 6)
       (setf obj (send guide-icon-proto :new w x y 45 13 :title title)))
      ((= icon-type 7)
       (setf obj (send and-icon-proto   :new w x y 45 13 :title title)))
      )
      obj))


(defmeth guidemap-proto :add-plot-help-item  () nil)

;;define help button overlay prototype and methods

(defproto help-overlay-proto '() () graph-overlay-proto)

(defmeth help-overlay-proto :redraw ()
  (let* ((graph (send self :graph))
         (scroll (send graph :scroll))
         (scrollx (first scroll))
         (scrolly (second scroll))
         (draw-color (send graph :draw-color))
         (cw (send graph :canvas-width))
         (th (+ (send graph :text-ascent) (send graph :text-descent)))
         (tw (send graph :text-width "Help")))
    (if (send graph :use-color)
        (send graph :draw-color 'toolbar-background)
        (send graph :draw-color 'white))
    (send graph :paint-rect 0  0 cw 18)
    (send graph :draw-color 'black)
    (send graph :draw-line 0 18 cw 18)
    (send graph :draw-color 'white)
    (send graph :paint-rect 6 3 10 10)
    (send graph :draw-color 'black)
    (send graph :frame-rect 6 3 10 10)
  ;  (send graph :draw-string "Help" 19 th)
    (send graph :draw-string "Help" 19 13)
    (send graph :draw-color draw-color)))

(defmeth help-overlay-proto :do-click (x y m1 m2 graph)
  (let* ((scroll (send graph :scroll))
         (scrollx (first scroll))
         (scrolly (second scroll))
         (tw (send graph :text-width "Help")))
  (when (and (< (+ scrollx 6) x (+ scrollx tw 28))  10 20
             (< (+ scrolly 3) y (+ scrolly 18)))  6 16
        (send graph :show-help graph))))

(defmeth guidemap-proto :show-help (icon)
  (let* ((title (send icon :title))
         (i (min (list 8 (length title))))
         (help-file-name title)
         (w (send *vista* :help-window-object))
        )
    (when (equal "GoTo" (subseq title 0 4)) 
          (setf title "GoTo")
          (setf help-file-name title)
          (setf i 4))
    (when (and (> i 4) (equal ":" (subseq title 4 5)) )
          (setf help-file-name (subseq title 5 (length title)))
          (when (> (length help-file-name) 8)
                (setf help-file-name (subseq help-file-name 0 8)))
          (when (> i (length help-file-name))
                (setf i (length help-file-name)))
          )
    (setf help-file-name 
          (strcat *help-dir-name* 
             (string-downcase (subseq (blanks-to-dashes help-file-name) 0 i)) ".hlp"))
#+macintosh (file-to-window help-file-name title w)
#-macintosh (file-to-stream help-file-name title)
    ))

;;debugging code

(setf investigate nil) 

(defun check ()
  (format t "Applets: ~s   Applet Name: ~s   Internal-Map: ~s ~%"
          (send *vista* :applets)
          (send *vista* :applet-name)
          (send *vista* :internal-map)
          )
  (when current-object (format t "GuideMap Ancestors: ~s" 
                               (send current-object :guidemap-ancestors))) 
  )
